home *** CD-ROM | disk | FTP | other *** search
/ TestDrive Windows 1993 Fall / TestDrive Windows 1993 Fall.iso / dbase / samples / goods.prg < prev    next >
Encoding:
Text File  |  1993-03-09  |  8.0 KB  |  238 lines
  1. ******************************************************************************
  2. * PROGRAM NAME: GOODS.PRG
  3. *               INVENTORY DATABASE SCREEN
  4. *               SAMPLE BUSINESS APPLICATION PROGRAM
  5. * LAST CHANGED: 09/25/89 09:26AM
  6. * WRITTEN BY:   Borland International Inc.
  7. ******************************************************************************
  8. *
  9. *       FILES USED:
  10. *       Database file      =  Goods.dbf  (Inventory file)
  11. *       Index file         =  Goods.mdx
  12. *           TAG: Part_id   =  part_id   <= Master index
  13. *           TAG: Vendor_id =  vendor_id
  14. *       External procedure file = Library.prg
  15. ******************************************************************************
  16.  
  17. * Main procedure
  18. PROCEDURE Goods
  19.  
  20.    * Link to external procedure file of "tool" procedures
  21.    SET PROCEDURE TO Library
  22.  
  23.    * Set up database environment
  24.    DO Set_env
  25.  
  26.    SET COLOR TO &c_standard.
  27.  
  28.    * Declare variables used:
  29.    * Database memory variables
  30.    STORE ""  TO part_id, part_name, descript, vendor_id, comments
  31.    STORE 0   TO price, cost, qty_onhand, qty_2order, lead_time
  32.    discontinu = .F.
  33.  
  34.    * Miscellaneous variables - used to pass parameters to Library
  35.    dbf      = "GOODS"                    && Standard report is available
  36.    mlist    = "NOT AVAILABLE"            && No mailing list available
  37.    cust_rpt = "N/A"                      && No custom reports available
  38.    STORE "m->part_id" TO key, key1
  39.    STORE "NONE" TO key2, key3
  40.    keyname1 = "Part ID:"
  41.    STORE "" TO keyname2, keyname3, mvendorid
  42.    list_flds = "PART_ID, PART_NAME, QTY_ONHAND"
  43.  
  44.    * Open database files and choose active index files
  45.    SELECT 1
  46.    USE Goods ORDER Part_id
  47.    GO TOP
  48.    * Used for vendor data lookup
  49.    USE Vendors ORDER Vendor_id IN 2
  50.  
  51.    record_num = RECNO()
  52.    DO Load_fld
  53.  
  54.    * Show data screen
  55.    CLEAR
  56.    DO Dstatus
  57.    DO Backgrnd
  58.    DO Show_data
  59.  
  60.    * Define popup menus
  61.    DO Bar_def
  62.  
  63.    * Activate main popup menu - execute user choices
  64.    SET COLOR TO &c_popup.
  65.    ACTIVATE POPUP main_mnu
  66.    DO Sub_ret
  67.    *
  68. RETURN
  69. *======================== end of main procedure ==============================
  70.  
  71. *  UTILITY PROCEDURES (Proprietary to Goods.prg)
  72.  
  73. PROCEDURE Filter
  74.    * Filter (group) data into subset
  75.    * Select subset to set up filter condition (Y=turn on, N=abort selection,
  76.    * T=turn off). If filter is already on, set default choice to T, show 
  77.    * window. If filter is not on, set default choice to Y, show window.
  78.    choice = IIF(filters_on,"T","Y")
  79.    DO Filt_ans
  80.    IF choice = "Y"
  81.       * Start process of choosing filter condition
  82.       mvendorid  = SPACE(4)
  83.       ACTIVATE WINDOW alert
  84.          * Get user's filter condition selection(s)
  85.          @  0, 0 SAY "-------- ENTER FILTER CONDITION --------"
  86.          @  2, 0 SAY "VENDOR ID:" GET mvendorid FUNCTION "9"
  87.          READ
  88.       DEACTIVATE WINDOW alert
  89.       *
  90.       * Check whether data entered into subset string
  91.       IF "" = TRIM(mvendorid)
  92.          filters_on = .F.
  93.          DO Warnbell
  94.       ELSE
  95.          * Filter on entered filter string condition
  96.          SET FILTER TO vendor_id = TRIM(mvendorid)
  97.          * Activate filter by moving record pointer
  98.          GO TOP
  99.          * Check whether filter condition matches any records (no match=EOF)
  100.          filters_on = .NOT. EOF()   && Filter is turned on if .T.
  101.          IF .NOT. filters_on
  102.             * Turn off filter if no matching records found
  103.             DO Warnbell
  104.             DO Show_msg WITH "No Goods (inventory) records match the " + ;
  105.                              "filter condition"
  106.             SET FILTER TO
  107.             GO record_num
  108.          ENDIF
  109.       ENDIF
  110.    ELSE
  111.       IF choice = "T"
  112.          * If user selects "T", turn off filter
  113.          SET FILTER TO
  114.          filters_on = .F.
  115.       ENDIF
  116.    ENDIF
  117. RETURN
  118.  
  119. PROCEDURE Indexer
  120.    * Create/rebuild indexes
  121.    INDEX ON vendor_id TAG Vendor_id
  122.    INDEX ON part_id   TAG Part_id
  123.    GO TOP
  124. RETURN
  125.  
  126. PROCEDURE Init_fld
  127.    * Initialize memory variable values for data entry
  128.    part_id   = SPACE(10)
  129.    STORE SPACE(30) TO part_name, descript, comments
  130.    STORE 0 TO qty_onhand, cost, price, qty_2order, lead_time
  131.    vendor_id = SPACE(4)
  132. RETURN
  133.  
  134. PROCEDURE Load_fld
  135.    * Load field values from Goods database record into memory variables
  136.    part_id    = part_id
  137.    part_name  = part_name
  138.    descript   = descript
  139.    qty_onhand = qty_onhand
  140.    cost       = cost
  141.    price      = price
  142.    qty_2order = qty_2order
  143.    vendor_id  = vendor_id
  144.    lead_time  = lead_time
  145.    comments   = comments
  146. RETURN
  147.  
  148. PROCEDURE Repl_fld
  149.    * Replace database fields with values of current memory variables
  150.    REPLACE part_id WITH m->part_id, part_name WITH m->part_name, ;
  151.            descript WITH m->descript, qty_onhand WITH m->qty_onhand, ;
  152.            cost WITH m->cost, price WITH m->price, ;
  153.            qty_2order WITH m->qty_2order, vendor_id WITH m->vendor_id, ;
  154.            lead_time WITH m->lead_time, comments WITH m->comments
  155. RETURN
  156.  
  157. PROCEDURE Backgrnd
  158.    * Show background screen
  159.    * Draw and fill in boxes
  160.    @  1,17 TO  3,46 DOUBLE COLOR &c_blue.
  161.    @  5, 2 TO  7,30 DOUBLE COLOR &c_red.
  162.    @  2,18 FILL TO  2,45   COLOR &c_blue.
  163.    @  6, 3 FILL TO  6,29   COLOR &c_red.
  164.    @  9, 3 FILL TO 18,54   COLOR &c_red.
  165.    @ 13, 3 TO 13,54        COLOR &c_red.
  166.    @  8, 2 TO 19,55        COLOR &c_red.
  167.    SET COLOR TO &c_data.
  168.    @  2,19 SAY "GOODS (INVENTORY) DATABASE"
  169.    @  6, 4 SAY "PART NO.:"
  170.    @  9, 4 SAY "NAME:"
  171.    @ 10, 4 SAY "DESCRIPTION:"
  172.    @ 11, 4 SAY "SALES PRICE:"
  173.    @ 12, 4 SAY "QUANTITY ON HAND:"
  174.    @ 12,32 SAY "DISCONTINUED:"
  175.    @ 14, 4 SAY "VENDOR NUMBER:"
  176.    @ 15, 4 SAY "COST:     $"
  177.    @ 16, 4 SAY "QUANTITY TO ORDER:"
  178.    @ 16,29 SAY "(minimum/batch)"
  179.    @ 17, 4 SAY "LEAD TIME:"
  180.    @ 17,20 SAY "(in days)"
  181.    @ 18, 4 SAY "COMMENTS:"
  182.    SET COLOR TO &c_standard.
  183. RETURN
  184.  
  185. PROCEDURE Show_data
  186.    * Show screen for data entry
  187.    SET COLOR TO &c_fields.
  188.    @  6,15 SAY part_id
  189.    @  9,17 SAY part_name
  190.    @ 10,17 SAY descript
  191.    @ 11,17 SAY price      PICTURE  "99,999.99"
  192.    @ 12,22 SAY qty_onhand PICTURE  "9,999"
  193.    @ 12,46 SAY discontinu PICTURE  "Y"
  194.    @ 14,19 SAY vendor_id
  195.    @ 15,16 SAY cost       PICTURE  "99,999.99"
  196.    @ 16,23 SAY qty_2order PICTURE  "9,999"
  197.    @ 17,16 SAY lead_time  PICTURE  "999"
  198.    @ 18,16 SAY comments
  199.    SET COLOR TO &c_standard.
  200. RETURN
  201.  
  202. PROCEDURE Get_data
  203.    * Show screen for data entry
  204.    SET COLOR TO &c_data.
  205.    @  6,15 GET m->part_id    FUNCTION "!" ;
  206.            VALID Duplicat(&key.) ;
  207.            ERROR "Duplicate part ID number, please re-enter" ;
  208.            MESSAGE "Enter a part ID number, or Esc to quit"
  209.    @  9,17 GET m->part_name  FUNCTION "!" ;
  210.            MESSAGE "Enter the name of the part"
  211.    @ 10,17 GET m->descript   FUNCTION "!" ;
  212.            MESSAGE "Enter a description of the part"
  213.    @ 11,17 GET m->price      PICTURE  "99,999.99" ;
  214.            MESSAGE "Enter the selling price of this part"
  215.    @ 12,22 GET m->qty_onhand PICTURE  "9,999" ;
  216.            MESSAGE "Enter how many of these parts are in current inventory"
  217.    @ 12,46 GET m->discontinu PICTURE  "Y" ;
  218.            MESSAGE "Is the part now discontinued (Y/N)"
  219.    @ 14,19 GET m->vendor_id  FUNCTION "9" ;
  220.            VALID Lookupid((m->vendor_id),"Vendors", "Vendor",1) ;
  221.            ERROR "Invalid vendor ID number, please re-enter" ;
  222.            MESSAGE "Enter a vendor ID number, or Esc to quit"
  223.    @ 15,16 GET m->cost       PICTURE  "99,999.99" ;
  224.            MESSAGE "Enter the cost of the part"
  225.    @ 16,23 GET m->qty_2order PICTURE  "9,999" ;
  226.            MESSAGE "Enter the minimum quantity which can be ordered"
  227.    @ 17,16 GET m->lead_time  PICTURE  "999" ;
  228.            MESSAGE "Enter the lead time before vendor " + ;
  229.                    "typically ships the parts"
  230.    @ 18,16 GET m->comments   FUNCTION "!" ;
  231.            MESSAGE "Enter any comments on this part"
  232.    SET COLOR TO &c_standard.
  233.    ON KEY LABEL F9 DO Findvend WITH m->vendor_id
  234. RETURN
  235.  
  236. *********************************** END OF GOODS.PRG *************************
  237.  
  238.